Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/prtgrid2/prtgrid.pas

Pascal/Delphi Source File | 1995-12-22 | 20KB | 860 lines

unit Prtgrid;

interface

uses
  SysUtils,  WinTypes,  WinProcs,  Messages,  Classes,  Graphics,  Controls,
    Forms,  Dialogs, DBGrids, DB
    ;

const
    MaxPages = 1000;
    MaxCols = 100;


type
    TPageNumberPos = (pnNone,  pnTopLeft, pnTopCenter, pnTopRight, pnBotLeft, pnBotCenter, pnBotRight);


  TPrintGrid = class(TComponent)
  private
    { Private declarations }
        tmpFile: Text;
        tmpFileName : TFileName;
        FDBGrid: TDBGrid;
        FHeaderInTitle: boolean;
        FHeaderAlign: TAlignment;
        FLinesFont: TFont;
        FHeaderFont: TFont;
        FTitleFont: TFont;
        FPageNLabel: string;
        FDateLabel: string;
        FPageNPos: TPageNumberPos;
        FDatePos: TPageNumberPos;
        FPrintFileName: string;
        FHeader: string;
        FPrintMgrTitle: string;
        FirstRecordY: longint;
        LinesWidth: longint;
        LinesHeight: longint;
        RecCounter: longint;
        FToPrint: boolean;
        tmpPageNo: longint;
        FFromPage: longint;
        FToPage: longint;
        NPositions: integer;
        FTopMargin: integer;
        FBottomMargin: integer;
        FLeftMargin: integer;
        FRightMargin: integer;
        Positions: array[1..MaxCols] of longint;
        FColLines: boolean;
        FRowLines: boolean;
        FBorder: boolean;
        FHorizGap: integer;
        FVertGap: integer;

        procedure WriteLineScreen(const S: string);
        procedure SetTitleFont(Value: TFont);
        procedure SetHeaderFont(Value: TFont);
        procedure SetLinesFont(Value: TFont);
        procedure SetDBGrid(Value: TDBGrid);
        function GetDBGrid: TDBGrid;
        procedure SetPrintMgrTitle(const S: string);
        function GetPrintMgrTitle: string;
        function OpenTextForWrite: boolean;
        function ScreenWidth(tmp: TField): longint;
        function TitleWidth(const S: string): longint;
        function TitleHeight: longint;
        procedure CalculatePositions;
        function SetAlign(align:TAlignment; Left, Right: longint): longint;
        function SetPagePosX(PagePos: TPageNumberPos; Left, Right: longint): longint;
        function SetPagePosY(PagePos: TPageNumberPos; Top, Bottom: longint): longint;
        function PrepareAlign(Field: TField; Col: integer): longint;
        procedure WriteHeaderToPrinter;
        procedure WriteLabelToPrinter(PosY: longint);
        procedure WriteRecordToPrinter;
        procedure WriteHeader;
        procedure WriteRecord;
        procedure PageJump;
        function RealWidth: longint;
        function AllPageFilled: boolean;

  protected
        { Protected declarations }
    procedure SetName(const Value: TComponentName); override;

  public
    { Public declarations }
        constructor Create(AOwner:TComponent); override;
        destructor Destroy; override;
    procedure Print;
    procedure PrintDialog;

    published
        { Published declarations }
        property LeftMargin: integer read FLeftMargin write FLeftMargin;
        property TopMargin: integer read FTopMargin write FTopMargin;
        property RightMargin: integer read FRightMargin write FRightMargin;
        property BottomMargin: integer read FBottomMargin write FBottomMargin;
        property TitleFont: TFont read FTitleFont write SetTitleFont;
        property HeaderFont: TFont read FHeaderFont write SetHeaderFont;
        property LinesFont: TFont read FLinesFont write SetLinesFont;
        property DBGrid: TDBGrid read GetDBGrid write SetDBGrid;
        property PrintMgrTitle: string read GetPrintMgrTitle write SetPrintMgrTitle;
{        property HeaderInTitle: boolean read FHeaderInTitle write FHeaderinTitle;}{cannot get this to work properly}
        property Header: string read FHeader write FHeader;
        property HeaderAlignment: TAlignment read FHeaderAlign write FHeaderAlign;
        property PrintToFile: boolean read FToPrint write FToPrint;
        property PrintFileName: string read FPrintFileName write FPrintFileName;
        property FromPage: longint read FFromPage write FFromPage;
    property ToPage: longint read FToPage write FToPage;
        property Border: boolean read FBorder write FBorder;
        property ColLines: boolean read FColLines write FColLines;
        property RowLines: boolean read FRowLines write FRowLines;
        property HorizontalGap: integer read FHorizGap write FHorizGap;
        property VerticalGapPct: integer read FVertGap write FVertGap;
        property PageNumberPos: TPageNumberPos read FPageNPos write FPageNPos;
        property PageNumberLabel: string read FPageNLabel write FPageNLabel;
        property DatePos: TPageNumberPos read FDatePos write FDatePos;
        property DateLabel: string read FDateLabel write FDateLabel;
    end;

procedure Register;


implementation

uses
    Printers;


function Max(a, b: longint): longint;
begin
    if a > b then
        Result := a
    else
        Result := b;
end;


function FileNameExists(FileName: string): boolean;    { Check whether file exists and return true if it does }
var
    F: File;
begin
  Assign(F, FileName);
    {$I-} Reset(F); {$I+}

    if IoResult <> 0 then
        begin
            FileNameExists := false;                                      { i.e. file information is in memory }
        end
    else
        begin
            Close(F);                                                            { Note: File does NOT remain open }
            FileNameExists := true;                                          { i.e. file information is in memory }
        end;

end;


function Scale(Value: longint; Pct: integer): longint;
begin
    if Pct > 100 then
        Pct := 100
    else if Pct < 0 then
        Pct := 0;

    if Pct = 0 then
        Result := Value
    else
        Result := Value + MulDiv(Value, Pct, 100);
end;


function CenterY(PosY, TextHt, Pct: longint): longint;
begin
    Result := PosY + (Scale(TextHt, Pct) - TextHt) div 2;
end;



constructor TPrintGrid.Create(AOwner:TComponent);
begin
    inherited Create(AOwner);
    FTitleFont := TFont.Create;
    FHeaderFont := TFont.Create;
    FLinesFont := TFont.Create;

    { DEFAULT VALUES FOR ALL PROPERTIES }
    FDBGrid := nil;
  FHeader := '';
  FPrintMgrTitle := '';
  RecCounter := 0;
  FHorizGap := 2;
    FVertGap := 20;
    FTopMargin := 40;
    FBottomMargin := 40;
    FLeftMargin := 30;
    FRightMargin := 30;
    FToPrint := False;
    FPrintFileName := '';
  FFromPage := 1;
  FToPage := MaxPages;
    FBorder := True;
    FColLines := True;
    FRowLines := False;
  FHeaderAlign := taCenter;
  FHeaderIntitle := False;
    FPageNPos := pnTopRight;
    FPageNLabel := 'Page: ';
    FDatePos := pnTopLeft;
    FDateLabel := '';
end;


destructor TPrintGrid.Destroy;
begin
    FTitleFont.Free;
    FHeaderFont.Free;
  FLinesFont.Free;
    inherited Destroy;
end;


procedure TPrintGrid.SetTitleFont(Value: TFont);
begin
    FTitleFont.Assign(Value);
end;


procedure TPrintGrid.SetHeaderFont(Value: TFont);
begin
    FHeaderFont.Assign(Value);
end;


procedure TPrintGrid.SetLinesFont(Value: TFont);
begin
    FLinesFont.Assign(Value);
end;


procedure TPrintGrid.SetDBGrid(Value: TDBGrid);
begin
    FDBGrid := Value;
end;


function TPrintGrid.GetDBGrid: TDBGrid;
begin
    Result := FDBGrid;
end;


procedure TPrintGrid.SetPrintMgrTitle(const S: string);
begin
    FPrintMgrTitle := S;
end;


function TPrintGrid.GetPrintMgrTitle: string;
begin
    Result := FPrintMgrTitle;
end;


procedure TPrintGrid.SetName(const Value: TComponentName);
var
  ChangeText: Boolean;
begin
    ChangeText := (Name = FPrintMgrTitle) and ((Owner = nil) or not (Owner is TPrintGrid) or
                                    not (csLoading in TPrintGrid(Owner).ComponentState));

    inherited SetName(Value);

    if ChangeText then
        FPrintMgrTitle := Value;
end;


procedure TPrintGrid.WriteLineScreen(const S: string);
begin
    if (tmpPageNo >= FFromPage) and (tmpPageNo <= FToPage) then
        Writeln(tmpFile, S);
end;


function TPrintGrid.OpenTextForWrite: boolean;
begin
    if tmpFileName <> '' then
        begin
            {$I-}
            AssignFile(tmpFile, tmpFileName);
            rewrite(tmpFile);
            {$I+}
            Result := (ioresult = 0);
        end

    else
        Result := false;
end;


function TPrintGrid.ScreenWidth(tmp:TField): longint;
begin
    Result := Max(tmp.DisplayWidth, Length(tmp.DisplayLabel));
end;


function TPrintGrid.TitleWidth(const S: string): longint;
var
    tmpFont: TFont;
begin
    with Printer.Canvas do
    begin
        tmpFont := TFont.Create;
        tmpFont.Assign(Font);
        Font.Assign(FTitleFont);
        Result := TextWidth(s);
        Font.Assign(tmpFont);
        tmpFont.Free;
    end;
end;


function TPrintGrid.TitleHeight: longint;
var
    tmpFont: TFont;
begin
    with Printer.Canvas do
    begin
        tmpFont := TFont.Create;
        tmpFont.Assign(Font);
        Font.Assign(FTitleFont);
        Result := Scale(TextHeight('M'), FVertGap);
        Font.Assign(tmpFont);
        tmpFont.Free;
    end;
end;


procedure TPrintGrid.CalculatePositions;
var
    ColWidth, t: longint;
begin
    NPositions := 0;

    if FBorder then
        Positions[1] := 1
    else
        Positions[1] := 0;

    with FDBGrid.DataSource.DataSet do

        for t := 0 to FieldCount - 1 do
        with Fields[t] do

        if Visible then
        begin
            inc(NPositions);
            ColWidth := Max(TitleWidth(Fields[t].DisplayLabel), (LinesWidth * Fields[t].DisplayWidth));
            Positions[NPositions + 1] := Positions[NPositions] + ColWidth + FHorizGap;
        end;
end;


function TPrintGrid.SetAlign(align: TAlignment; Left, Right: longint): longint;
var
    PosX: longint;
begin
    with Printer.Canvas do
    begin
        case Align of
            taLeftJustify:
                begin
                    SetTextAlign(Handle, TA_LEFT);
                    PosX := Left + FHorizGap;
                end;

            taRightJustify:
                begin
                    SetTextAlign(Handle, TA_RIGHT);
                    PosX := Right - FHorizGap;
                end;

            taCenter:
                begin
                    SetTextAlign(Handle, TA_CENTER);
                    PosX := Left + Round((Right - Left) / 2);
                end;
        end;
    end;

    Result := PosX;
end;


function TPrintGrid.SetPagePosX(PagePos: TPageNumberPos; Left, Right: longint): longint;
var
    PosX: longint;
begin
    with Printer.Canvas do
    begin
        case PagePos of
            pnTopLeft, pnBotLeft:
                begin
                    SetTextAlign(Handle, TA_LEFT);
                    PosX := Left + FHorizGap;
                end;

            pnTopRight, pnBotRight:
                begin
                    SetTextAlign(Handle, TA_RIGHT);
                    PosX := Right - FHorizGap;
                end;

            pnTopCenter, pnBotCenter:
                begin
                    SetTextAlign(Handle, TA_CENTER);
                    PosX := Left + Round((Right - Left)/2);
                end;
        end;
    end;

    Result := PosX;
end;


function TPrintGrid.SetPagePosY(PagePos: TPageNumberPos; Top, Bottom: longint): longint;
var
    PosY: longint;
begin
        case PagePos of
            pnBotLeft, pnBotCenter, pnBotRight:
                begin
                    PosY := Bottom;
                end;

        else
            PosY := Top;
        end;

    Result := PosY;
end;


function TPrintGrid.PrepareAlign(Field:TField; Col:integer): longint;
begin
    Result := SetAlign(Field.Alignment, Positions[col], Positions[col + 1]);
end;


procedure TPrintGrid.WriteHeaderToPrinter;
var
    PosX, PosY, t, tmpTitleHeight: longint;
    TmpFont: TFont;
    FontCreated: boolean;
begin
    if (tmpPageNo >= FFromPage) and (tmpPageNo <= FToPage) then
    begin
        tmpTitleHeight := TitleHeight;

        with Printer.Canvas do
        begin
            if (FHeader <> '') or (FDatePos <> pnNone) or (FPageNPos <> pnNone) then
                begin
                    tmpFont := TFont.Create;
                    tmpFont.Assign(Font);
                    Font.Assign(FHeaderFont);
                    FontCreated := true;
                end
            else
                FontCreated := false;

            if FDatePos <> pnNone then
            begin
                PosX := SetPagePosX(FDatePos, FLeftMargin, FLeftMargin + Positions[NPositions + 1]);
                PosY := SetPagePosY(FDatePos, FTopMargin, Printer.PageHeight - FBottomMargin);
                TextOut(PosX, PosY, FDateLabel);
            end;

            if FHeader <> '' then
            begin
                PosX := SetAlign(FHeaderAlign, FLeftMargin, FLeftMargin + Positions[NPositions + 1]);
                TextOut(PosX, FTopMargin, FHeader);
            end;

            if FPageNPos <> pnNone then
            begin
                PosX := SetPagePosX(FPageNPos, FLeftMargin, FLeftMargin + Positions[NPositions + 1]);
                PosY := SetPagePosY(FPageNPos, FTopMargin, Printer.PageHeight - FBottomMargin);
                TextOut(PosX, PosY, FPageNLabel + IntToStr(tmpPageNo));
            end;

            if (FHeader <> '') or (FDatePos in [pnTopLeft, pnTopCenter, pnTopRight])
                                                 or (FPageNPos in [pnTopLeft, pnTopCenter, pnTopRight]) then
                FirstRecordY := FTopMargin + Scale(TextHeight('M'), FVertGap) + tmpTitleHeight
            else
                FirstRecordY := FTopMargin + tmpTitleHeight;

            if FontCreated then
            begin
                Font.Assign(tmpFont);
                tmpFont.Free;
            end;
        end;

        if FBorder then
        begin
            if FHeaderinTitle then
                Printer.Canvas.Rectangle(FLeftMargin, FTopMargin, FLeftMargin + Positions[NPositions + 1],
                                                                 Printer.PageHeight - FBottomMargin)
            else
                Printer.Canvas.Rectangle(FLeftMargin, FirstRecordY - tmpTitleHeight, FLeftMargin + Positions[NPositions + 1],
                                                                 Printer.PageHeight - FBottomMargin)
        end;

        if FColLines then
            with Printer.Canvas do
            for t := 2 to NPositions do
            begin
                MoveTo(FLeftMargin + Positions[t], FirstRecordY);
                LineTo(FLeftMargin + Positions[t], Printer.PageHeight - FBottomMargin);
            end;

        WriteLabelToPrinter(FirstRecordY - tmpTitleHeight);
    end;
end;


procedure TPrintGrid.WriteLabelToPrinter(PosY: longint);
var
    Col, PosX, t: longint;
    TmpFont: TFont;
    R: TRect;
begin
    with FDBGrid.DataSource.DataSet do
        with Printer.Canvas do
        begin
            tmpFont := TFont.Create;
            tmpFont.Assign(Font);
            Font.Assign(FTitleFont);
            Col := 0;
            R.top := CenterY(PosY, TextHeight('M'), FVertGap);;
            R.bottom := FirstRecordY + ((RecCounter + 1) * LinesHeight);

            for t := 0 to FieldCount - 1 do
            begin
                if Fields[t].Visible then
                begin
                    inc(Col);
                    PosX := FLeftMargin + PrepareAlign(Fields[t], Col);
                    R.left := FLeftMargin + Positions[Col] + FHorizGap;
                    R.right := FLeftMargin + Positions[Col+1] - FHorizGap;
                    TextRect(R, PosX, R.top, Fields[t].DisplayLabel);
                end;
            end;

            Moveto(FLeftMargin, FirstRecordY);
            Lineto(FLeftMargin + Positions[NPositions + 1], FirstRecordY);
            Font.Assign(tmpFont);
            tmpFont.Free;
        end;
end;


procedure TPrintGrid.WriteRecordToPrinter;
var
    Col, t, PosX, PosY: longint;
    tmpFont: TFont;
    R: TRect;
begin
    if (tmpPageNo >= FFromPage) and (tmpPageNo <= FToPage) then
    begin
        with FDBGrid.DataSource.DataSet do
        begin
            with Printer.Canvas do
            begin
                tmpFont := TFont.Create;
                tmpFont.Assign(Font);
                Font.Assign(FLinesFont);
                Col := 0;
                PosY := FirstRecordY + RecCounter * LinesHeight;
                R.top := CenterY(PosY, TextHeight('M'), FVertGap);
                R.bottom := FirstRecordY + ((RecCounter + 1) * LinesHeight);

                for t := 0 to FieldCount - 1 do
                begin
                    if Fields[t].Visible then
                    begin
                        inc(Col);
                        PosX := FLeftMargin + PrepareAlign(Fields[t], Col);
                        R.left := FLeftMargin + Positions[Col] + FHorizGap;
                        R.right := FLeftMargin + Positions[Col+1] - FHorizGap;
                        TextRect(R, PosX, R.top, Fields[t].DisplayText);
                    end;
                end;

                if FRowLines then
                with Printer.Canvas do
                begin
                    MoveTo(FLeftMargin, PosY);
                    LineTo(FLeftMargin + Positions[NPositions + 1], PosY);
                end;

                Font.Assign(tmpFont);
                tmpFont.Free;
            end;
        end;
    end;
end;


procedure TPrintGrid.WriteHeader;
var
    t: longint;
    S: string;
begin
    if not FToPrint then
        WriteHeaderToPrinter

    else
        with FDBGrid.DataSource.DataSet do
        begin
            WriteLineScreen(FHeader);
            S := '';

      for t := 0 to FieldCount - 1 do
            begin
                if Fields[t].Visible then
                    S := S + Fields[t].DisplayLabel + #9;
            end;

            WriteLineScreen(S);
        end;
end;


procedure TPrintGrid.WriteRecord;
var
    t: word;
    S: string;
begin
    if not FToPrint then
        WriteRecordToPrinter

    else
        begin
            with FDBGrid.DataSource.DataSet do
            begin
                S := '';

                for t := 0 to FieldCount - 1 do
                begin
                    if Fields[t].Visible then
                        S := S + Fields[t].DisplayText + #9;
                end;
            end;

            WriteLineScreen(S);
        end;
end;


procedure TPrintGrid.PageJump;
begin
    RecCounter := 0;

    if not FToPrint then
        if (tmpPageNo >= FFromPage) and (tmpPageNo < FToPage) then
            Printer.NewPage;

    inc(tmpPageNo);
end;


function TPrintGrid.RealWidth: longint;
begin
    Result := Printer.PageWidth - FLeftMargin - FRightMargin;
end;


function TPrintGrid.AllPageFilled: boolean;
begin
    Result := (FToPrint and (RecCounter = 66)) or
                        (not FToPrint and
                        ((FirstRecordY + (RecCounter + 1) * LinesHeight) >= (Printer.PageHeight - FBottomMargin)));
end;


procedure TPrintGrid.Print;
var
    res: boolean;
    St: array[0..255] of Char;
    BookMark: TBookMark;
    t: integer;
    tmpFont: TFont;
begin
    if not Assigned(FDBGrid) then
        raise Exception.Create('PrintGrid. DBGrid Property Was Not Specified.');

    if FToPrint then
        res := OpenTextForWrite

  else
        begin
            res := true;

            with Printer do
            begin
                Title := FPrintMgrTitle;
                BeginDoc;

                with Canvas do
                begin
                    tmpFont := TFont.Create;
                    tmpFont.Assign(Font);
                    Font.Assign(FLinesFont);
                    LinesHeight := Scale(TextHeight('M'), FVertGap);
                    LinesWidth := TextWidth('0');
                    Font.Assign(tmpFont);
                    tmpFont.Free;
                end;
            end;
    end;

    if res then
  begin
    with FDBGrid.DataSource.DataSet do
        try
            Screen.Cursor := crHourGlass;
            Bookmark := GetBookMark;
      DisableControls;
      First;
      RecCounter := 0;
      tmpPageNo := 1;
            CalculatePositions; { where to place each field in horizontal plane? }

            if not FToPrint and (Positions[NPositions + 1] > RealWidth) then
            begin
                Screen.Cursor := crDefault;
                ShowMessage('Report Width Is Greater Than Paper Width.'); { useful in design }
                Screen.Cursor := crHourGlass;
            end;

            while not EOF do
      begin
                if RecCounter = 0 then
                    WriteHeader;

                WriteRecord;
                Inc(RecCounter);
                next;

                if AllPageFilled then
        begin
          PageJump;

                    if tmpPageNo > FToPage then
                        break;
        end;
            end;

    finally
            Screen.Cursor := crDefault;
            GotoBookMark(BookMark);
      EnableControls;
            FreeBookMark(BookMark);

            if FToPrint then
                System.closefile(tmpFile)
            else
                Printer.EndDoc;
    end;
    end

    else
        raise Exception.Create('Error Creating Report.');
end;


procedure TPrintGrid.PrintDialog;
var
    M: integer;
begin
    with TPrintDialog.Create(Self) do
    begin
        try
            Options := [poPageNums, poPrintToFile, poWarning];    {poHelp}
            MinPage := 1;
            MaxPage := MaxPages;
            FFromPage := 1;
            FToPage := MaxPages;

            if Execute then
            begin
                if PrintRange = prPageNums then
                begin
                    FFromPage := FromPage;
                    FToPage := ToPage;
                end;

                if not PrintToFile then
                    begin
                        FToPrint := false;
                        Print;
                    end
                else
                    begin
                        FToPrint := true;

                        with TSaveDialog.Create(Self) do
                        begin
                            try
                                Filter := 'Text files (*.TXT)|*.TXT|Any file (*.*)|*.*';

                                if FPrintFileName <> '' then
                                begin
                                    FileName := FPrintFileName;
                                    Filter := Filter + '|This file (*' + ExtractFileExt(FileName) + ')|*' + ExtractFileExt(FileName);
                                    FilterIndex := 3;
                                end;

                                if Execute then
                                begin
                                    M := mrYes;

                                    if FileNameExists(FileName) then
                                        M := MessageDlg(FileName + ' Already Exists. Do You Want To Overwrite This File?',
                                                                        mtConfirmation, [mbYes, mbNo], 0);

                                    if M = mrYes then
                                    begin
                                        tmpFileName := FileName;
                                        Print;
                                    end;
                                end;

                            finally
                                Free;
                            end;
                        end;
                    end;
            end;

        finally
            Free;
        end;
    end;
end;


procedure Register;
begin
    RegisterComponents('Data Controls', [TPrintGrid]);
end;


end.